home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / vaxlap.t < prev    next >
Text File  |  1988-05-02  |  10KB  |  333 lines
  1. (herald vaxlap (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.         
  26. ;;; lap code is of the form (lap free-vars . code)
  27. ;;; lap templates are (lap-template (pointer scratch nargs) . code)
  28.  
  29. (define local-processor
  30.   (lambda ()
  31.     (object nil
  32.       ((processor-type self)     'vax11)
  33.       ((vax-processor? self) '#t)
  34.       ((print-type-string self)  "Processor"))))
  35.  
  36. (define (template-definer-vcell-offset template)
  37.   (let ((template (if (fixnum-equal? (mref-16-u template -2) jump-absolute)
  38.                       (extend-elt template 0)
  39.                       template)))
  40.     (let ((offset (fixnum-ashr (mref-16-u template -12) 3)))
  41.       (if (fx= offset 0) 
  42.           nil
  43.           (fx- offset 1)))))
  44.  
  45. (define (invoke-stack-continuation frame vals)
  46.   (lap (return apply)
  47.     (subl2 ($ 2) A1)
  48.     (movl A1 SP)
  49.     (cmpl A2 nil-reg)
  50.     (beql (to no-values))
  51.     (cmpl (d@r A2 -3) nil-reg)
  52.     (bneq (to many-values))
  53.     (movl (d@r A2 1) A1)
  54.     (mnegl ($ 2) NARGS)
  55.     (movl (@r sp) tp)
  56.     (jmp (@r tp))
  57. no-values
  58.     (mnegl ($ 1) NARGS)
  59.     (movl (@r sp) tp)
  60.     (jmp (@r tp))
  61. many-values
  62.     (movl (d@r P (static 'return)) A1)
  63.     (movl (d@r a1 2) a1)
  64.     (movl (d@r P (static 'apply)) P)
  65.     (movl (d@r p 2) p)
  66.     (movl ($ 3) NARGS)
  67.     (movl (d@r p -2) tp)
  68.     (jmp (@r tp))))
  69.  
  70.  
  71. (define (invoke-continuation sp stack val base-state current-state)
  72.   (lap (rewind-state-and-continue)
  73.     (movl A1 SP)                    ; set new continuation
  74.     (movl (d@r TASK task/stack) S0) ; limit at stack base
  75.     (addl2 ($ 2) A2)                  ; start at first word of stack in heap
  76.     (brb (to copy-stack-test))
  77. copy-stack-loop 
  78.     (movl (@r+ A2) (@r+ A1))
  79. copy-stack-test
  80.     (cmpl A1 S0)
  81.     (bleq (to copy-stack-loop))
  82.     (movl A4 A1)
  83.     (movl (d@r TASK 16) A2)
  84.     (movl (d@r P (static 'rewind-state-and-continue)) P)
  85.     (movl (d@r p 2) p)
  86.     (movl ($ 4) NARGS)
  87.     (movl (d@r p -2) tp)
  88.     (jmp (@r tp))))
  89.  
  90.  
  91.  
  92.  
  93. ;;; (FIXNUM-HOWLONG n)
  94. ;;;   Returns the number of bits in N's binary representation.
  95. ;;;   Horrible name, after MACLISP function HAULONG.
  96.  
  97. (define (fixnum-howlong num)
  98.  (lap ()
  99.   (rotl ($ -2) A1 S0)        
  100.   (clrl A1)
  101.   (bitl ($ #xffff8000) S0)
  102.   (beql (to howlong1))
  103.   (bisl2 ($ (* 16 4)) A1)
  104.   (ashl ($ -16) S0 S0)
  105. howlong1
  106.   (bitl ($ #x7f80) S0)
  107.   (beql (to howlong2))
  108.   (bisl2 ($ (* 8 4)) A1)
  109.   (ashl ($ -8) S0 S0)
  110. howlong2
  111.   (bitl ($ #x78) S0)
  112.   (beql (to howlong3))
  113.   (bisl2 ($ (* 4 4)) A1)
  114.   (ashl ($ -4) S0 S0)
  115. howlong3
  116.   (bitl ($ #x6) S0)
  117.   (beql (to howlong4))
  118.   (bisl2 ($ (* 2 4)) A1)
  119.   (ashl ($ -2) S0 S0)
  120. howlong4
  121.   (bitl ($ #x1) S0)
  122.   (beql (to howlong5))
  123.   (bisl2 ($ (* 1 4)) A1)
  124. howlong5  
  125.   (mnegl ($ 2) NARGS)
  126.     (movl (@r sp) tp)
  127.     (jmp (@r tp))))
  128.  
  129.  
  130. (define (*set x y)
  131.   (lap ()  
  132.     (movl A2 (d@r A1 2))
  133.     (tstb (@r A1))
  134.     (beql (to foo-set))
  135.     (movl A1 (d@r TASK task/extra-pointer))
  136.     (jsb (*d@r nil-reg slink/set))
  137. foo-set
  138.     (mnegl ($ 2) NARGS)
  139.     (movl (@r sp) tp)
  140.     (jmp (@r tp))))
  141.  
  142.  
  143. (define (apply-traced-operation proc . args)
  144.   (lap (*traced-op-template*)
  145.     (movl (d@r P (static '*traced-op-template*)) TP)
  146.     (movl (d@r tp 2) tp)
  147.     (clrl (d@r TASK task/extra-scratch))
  148.     (jmp (label entry))))
  149.  
  150. (define (apply proc . args)
  151.  (lap (apply-too-many-args)                 
  152.   (movl ($ 1) (d@r TASK task/extra-scratch))
  153. entry
  154.   (decl NARGS)                        ;; shift proc out
  155.   (pushl P)                           ;; save env
  156.   (movl A1 P)                         ;; first arg is proc
  157.   (cmpl NARGS ($ 1))                  ;; no args to proc
  158.   (beql (to apply-done))
  159.   (decl NARGS)
  160.   (cmpl NARGS ($ 1))
  161.   (bneq (to next1))
  162.   (movl A2 AN)
  163.   (jmp (label apply-one-arg))
  164. next1
  165.   (cmpl NARGS ($ 2))
  166.   (bneq (to next2))
  167.   (movl A2 A1)
  168.   (movl A3 AN)
  169.   (jmp (label apply-two-args))
  170. next2
  171.   (cmpl NARGS ($ 3))
  172.   (bneq (to next3))
  173.   (movl A2 A1)
  174.   (movl A3 A2)
  175.   (movl A4 AN)                
  176.   (jmp (label apply-three-args))
  177. next3                         
  178.   (cmpl NARGS ($ 4))
  179.   (bneq (to next4))
  180.   (movl A2 A1)
  181.   (movl A3 A2)
  182.   (movl A4 A3)
  183.   (movl (d@r TASK 16) AN)           ;; first argument temp
  184.   (jmp (label apply-four-args))
  185. next4
  186.   (movl A2 A1)
  187.   (movl A3 A2)
  188.   (movl A4 A3)
  189.   (movl (d@r TASK 16) A4)            ;; first argument temp
  190.   (subl3 ($ 5) NARGS S1)             ;; S1 counts sown to 0
  191.   (addl3 TASK ($ 20) S2)             ;; set up S2 to point into rest vector
  192.                                      ;; first 4 temps reserved, 1 done already
  193.   (jmp (label apply-shift-test))
  194. apply-shift-loop-top
  195.   (movl (d@r S2 0) (d@r S2 -4))
  196.   (decl S1)
  197.   (addl2 ($ 4) S2)
  198. apply-shift-test
  199.   (cmpl S1 ($ 0))
  200.   (bneq (to apply-shift-loop-top))
  201.   (movl (d@r S2 0) AN)  
  202.   (subl2 ($ 4) S2)
  203.   (jmp (label apply-many-args))
  204. apply-one-arg
  205.   (cmpl AN nil-reg)   
  206.   (beql (to apply-done))
  207.   (movl (d@r AN 1) A1)                    
  208.   (addl2 ($ 1) NARGS)
  209.   (movl (d@r AN -3) AN)                   
  210. apply-two-args
  211.   (cmpl AN nil-reg)   
  212.   (beql (to apply-done))
  213.   (movl (d@r AN 1) A2)                    
  214.   (addl2 ($ 1) NARGS)
  215.   (movl (d@r AN -3) AN)                   
  216. apply-three-args
  217.   (cmpl AN nil-reg)   
  218.   (beql (to apply-done))
  219.   (movl (d@r AN 1) A3)                    
  220.   (addl2 ($ 1) NARGS)
  221.   (movl (d@r AN -3) AN)                   
  222. apply-four-args
  223.   (cmpl AN nil-reg)   
  224.   (beql (to apply-done))
  225.   (movl (d@r AN 1) A4)                    
  226.   (addl2 ($ 1) NARGS)
  227.   (movl (d@r AN -3) AN)      
  228.   (addl3 TASK ($ 16) S0)
  229. apply-spread-loop              
  230.   (cmpl AN nil-reg)
  231.   (beql (to apply-done))
  232.   (movl (d@r AN 1) (d@r S0 0))
  233.   (addl2 ($ 1) NARGS)
  234.   (cmpl ($ (+ *pointer-temps* 1)) NARGS)
  235.   (blss (to too-many))
  236.   (addl2 ($ 4) S0)
  237.   (movl (d@r AN -3) AN)
  238.   (jmp (label apply-spread-loop))
  239. too-many
  240.   (movl (@r+ SP) P)
  241.   (movl ($ 2) NARGS)
  242.   (movl (d@r P (static 'apply-too-many-args)) P)
  243.   (movl (d@r p 2) p)
  244.   (movl (d@r p -2) tp)
  245.   (jmp (@r tp))
  246. apply-done                    
  247.   (addl2 ($ 4) SP)
  248.   (tstl (d@r TASK task/extra-scratch))
  249.   (beql (to traced))
  250.   (movl (d@r p -2) tp)
  251.   (jmp (@r tp))
  252. traced
  253.   (jmp (@r TP))))
  254.  
  255.  
  256.  
  257.  
  258. (define (string-hash string)
  259.   ;; string in A1
  260.   (lap ()
  261.     ;; enter critical gc
  262.     (addl3 (d@r A1 offset/string-text) ($ 2) A3);; raw string text in A3
  263.     (addl2 (d@r A1 offset/string-base) A3)                              
  264. hash
  265.     (ashl ($ -8) (d@r A1 -2) S0)              ;; string-length in S0
  266.     (clrl S1)                                 ;; conter in S1
  267.     (clrl S2)                                 ;; hash value so far in S2
  268.     (jmp (label hash-test))
  269. hash-loop              
  270.     (rotl ($ 1) S2 S2)
  271.     (addb2 (@r+ A3) S2)
  272. hash-test  
  273.     (aobleq S0 S1 (to hash-loop))
  274.     (rotl ($ 16) S2 S1)
  275.     (xorl2 S1 S2)
  276.     (bicl3 ($ #x80000003) S2 A1)              ;; positive-fixnumize
  277.     ;; exit critical gc                       ;; blat bits 0,1,31
  278.     (mnegl ($ 2) NARGS)
  279.     (movl (@r sp) tp)
  280.     (jmp (@r tp))))
  281.  
  282.  
  283.  
  284.  
  285. ;;;  magic frame is next-state
  286. ;;;                 winder
  287. ;;;                 previous-state
  288. ;;;                 unwinder
  289. ;;;                 *magic-frame-template*
  290.  
  291. (define (push-magic-frame unwinder stuff wind)   
  292.  (lap (*magic-frame-template* bind-internal)
  293.   (movl (d@r TASK task/dynamic-state) AN)
  294.   (pushl nil-reg)                                      ; next state
  295.   (pushl A3)                                           ; winder
  296.   (pushl AN)                                           ; previous state
  297.   (pushl A1)                                          ; unwinder
  298.   (movl (d@r P (static '*magic-frame-template*)) a3)
  299.   (pushl (d@r a3 2))
  300.   (addl3 SP ($ 2) A1)                  ; first arg is the magic frame
  301.   (cmpl AN nil-reg)                     ; is there a previous state?
  302.   (beql (to magic-frame-exit))
  303.   (movl A1 (d@r AN 14))                ; set next slot to this magic frame
  304. magic-frame-exit
  305.   (movl (d@r P (static 'bind-internal)) P)   ; second arg is stuff
  306.   (movl (d@r p 2) p)
  307.   (movl ($ 3) NARGS)
  308.     (movl (d@r p -2) tp)
  309.     (jmp (@r tp))))
  310.  
  311.                    
  312. (define (make-structure-template size)
  313.   (lap (*structure-template* *stype-template*)
  314.     (movl (d@r P (static '*stype-template*)) AN)
  315.     (movl (d@r an 2) an)
  316.     (movl ($ 36) S1)                            ; 9 slots
  317.     (jsb (*d@r nil-reg slink/make-extend))
  318.     (movw ($ 32) (d@r AN 26))                     ; offset within closure
  319.     (movb ($ 0) (d@r AN 28))                     ; 0 scratch slots
  320.     (ashl ($ -2) A1 S0)                         ; pointer slots
  321.     (movb S0 (d@r AN 29))
  322.     (movw ($ header/template) (d@r AN 30))
  323.     (movw ($ VAX-JUMP-ABSOLUTE) (d@r AN 32))
  324.     (movl (d@r P (static '*structure-template*)) p)
  325.     (movl (d@r p 2) (d@r AN 34)) ; auxilliary
  326.     (moval (d@r AN 32) A1)                       ; template
  327.     (movl AN A2)                                ; stype
  328.     (mnegl ($ 3) NARGS)                         ; return two values
  329.     (movl (@r sp) tp)
  330.     (jmp (@r tp))))
  331.  
  332.  
  333.